\ load screen gst850930\ note: added negate's for true =-1 may not be needed : ?condition 0= if cr ." conditions mismatched" abort then ; : (s [compile] ( ; immediate : (p [compile] ( ; immediate \ ignore just like comment 2 19 thru \ load assembler \ 9 11 R .v. R@ \ 5 variable \ 9 create -dup .v. ?dup \ 12 cfa after ' for execute (still needed for f-79) \ 3 hide..unhide .v. smudge <builds .v. create \ 7 sp is a6 on sep.hd system \ 68000 Assembler a few examples gst850923 \ code FOO \ sp )+ d0 move \ pop one word to d0 \ 1 d0 addq \ add one to d0 \ 1 # d0 and \ mask just right bit \ 0<> if \ do following if non-zero \ sp )+ d0 long add word \ add long word from stack \ then \ revert to word length \ d0 sp -) move \ push resulting word in d0 \ end-code \ 68000 Assembler gst850930vocabulary ASSEMBLER immediate : subroutine \ -- | like code, but leaves its addr only create smudge [compile] assembler \ finish it sp@ csp ! ; \ primed for little safety too : code subroutine \ -- | start of a code definition \ CREATE SMUDGE \ start a definition, leave it smudged HERE LATEST PFA CFA ! ; \ <;CODE> to pt cfa to code\ [compile] assembler ; \ finish off this definition assembler definitions : end-code \ base -- | done with a code definition CURRENT @ CONTEXT ! ?CSP smudge ; \ 68000 Assembler gst850923ASSEMBLER DEFINITIONS : ?>MARK (S -- addr f ) HERE TRUE ; : ?>RESOLVE (S addr f -- ) ?CONDITION HERE OVER - SWAP 1- C! ; : ?<MARK (S -- addr f ) HERE TRUE ; : ?<RESOLVE (S addr f -- ) ?CONDITION HERE - HERE 1- C! ; \ DEFER C, FORTH ' C, ASSEMBLER IS C, \ DEFER , FORTH ' , ASSEMBLER IS , \ 68000 Meta Assembler gst851001\ : C; END-CODE ; : ?, IF , THEN , ; : 2, , , ; OCTAL VARIABLE SIZE \ fig forth : BYTE 10000 SIZE ! ; : WORD 30100 SIZE ! ; WORD : LONG 24600 SIZE ! ; : SZ CONSTANT DOES> @ SIZE @ AND OR ; 00300 SZ SZ3 00400 SZ SZ4 04000 SZ SZ40 30000 SZ SZ300 : LONG? SIZE @ 24600 = negate ; : -SZ1 LONG? IF 100 OR THEN ; VARIABLE INDEX-SIZE 0 INDEX-SIZE ! \ <>0 IF DI.L) \ addressing modes gst851001: REGS 10 0 DO DUP 1001 I * OR CONSTANT LOOP DROP ; : MODE CONSTANT DOES> @ SWAP 7007 AND OR ; 0000 REGS D0 D1 D2 D3 D4 D5 D6 D7 0110 REGS A0 A1 A2 A3 A4 A5 A6 A7 0220 MODE ) ( address register indirect ) 0330 MODE )+ ( adr reg ind post-increment ) 0440 MODE -) ( adr reg ind pre-decrement ) 0550 MODE D) ( adr reg ind displaced ) 0660 MODE DI) ( adr reg ind displaced indexed ) : DI.L) 7007 and 0660 or 1 index-size ! ; \ lond DI) mode0770 CONSTANT #) ( immediate address ) 1771 CONSTANT L#) ( immediate long address ) 2772 CONSTANT PCD) ( PC relative displaced ) 3773 CONSTANT PCDI) ( PC relative displaced indexed ) 4774 CONSTANT # ( immediate data ) \ fields and register assignments gst850930: FIELD CONSTANT DOES> @ AND ; 7000 FIELD RD 0007 FIELD RS 0070 FIELD MS 0077 FIELD EAS 0377 FIELD LOW : DN? (S ea -- ea flag ) DUP MS 0= negate ; : SRC (S ea instr -- ea instr' ) OVER EAS OR ; : DST (S ea instr -- ea instr' ) SWAP RD OR ; A5 CONSTANT SP ( Stack pointer ) A7 CONSTANT RP ( Return stack pointer ) A4 CONSTANT IP ( Interpreter pointer ) D6 CONSTANT W ( Working register Hi Word MUST be 0 ) D5 constant OS ( Hi word MUST be 0 ) A3 constant BP ( Base pointer for forth addr space ) \ extended addressing gst851001: DOUBLE? ( mode -- flag ) DUP L#) = negate SWAP # = negate LONG? AND OR ; : INDEX? ( {n} mode -- {m} mode ) \ DUP >R DUP 0770 AND A0 DI) OVER = OVER A0 DI.L) = \ OR SWAP >R SWAP PCDI) = OR \ flag (t=indexed) DUP >R DUP 0770 AND A0 DI) = negate SWAP PCDI) = negate or IF DUP RD 10 * SWAP MS IF 100000 OR THEN \ R> A0 DI.L) = IF 4000 OR R> 7667 and >R THEN index-size @ if 4000 or 0 index-size ! then ( SZ40 ) SWAP LOW OR ( ELSE R> DROP ) THEN R> ; : MORE? ( ea -- ea flag ) DUP MS 0040 > negate ; : ,MORE ( ea -- ) MORE? IF INDEX? DOUBLE? ?, ELSE DROP THEN ; \ extended addressing extras gst850929create EXTRA HERE 6 DUP ALLOT ERASE \ temporary storage area : EXTRA? ( {n} mode -- mode ) MORE? IF >R R@ INDEX? DOUBLE? EXTRA 1+ SWAP IF 2! 2 ELSE ! 1 THEN EXTRA C! R> ELSE 0 EXTRA ! THEN ; : ,EXTRA ( -- ) EXTRA C@ ?DUP IF EXTRA 1+ SWAP 1 = IF @ , ELSE 2@ 2, THEN EXTRA 5 ERASE THEN ; \ immediates & address register specific gst850923: IMM CONSTANT DOES> @ >R EXTRA? EAS R> OR SZ3 , LONG? ?, ,EXTRA ; ( n ea ) 0000 IMM ORI 1000 IMM ANDI 2000 IMM SUBI 3000 IMM ADDI 5000 IMM EORI 6000 IMM CMPI : IMMSR CONSTANT DOES> @ SZ3 2, ; ( n ) 001074 IMMSR ANDI>SR 005074 IMMSR EORI>SR 000074 IMMSR ORI>SR : IQ CONSTANT DOES> @ >R EXTRA? EAS SWAP RS 1000 * OR R> OR SZ3 , ,EXTRA ; ( n ea ) 050000 IQ ADDQ 050400 IQ SUBQ : IEAA CONSTANT DOES> @ DST SRC SZ4 , ,MORE ; ( ea An ) 150300 IEAA ADDA 130300 IEAA CMPA 040700 IEAA LEA 110300 IEAA SUBA \ shifts, rotates, and bit manipulation gst850929: ISR CONSTANT DOES> @ >R DN? IF SWAP DN? IF R> 40 OR >R ELSE DROP SWAP 1000 * THEN RD SWAP RS OR R> OR 160000 OR SZ3 , ELSE DUP EAS 300 OR R@ 400 AND OR R> 70 AND 100 * OR 160000 OR , ,MORE THEN ; ( Dm Dn ) ( m # Dn ) ( ea ) 400 ISR ASL 000 ISR ASR 410 ISR LSL 010 ISR LSR 420 ISR ROXL 020 ISR ROXR 430 ISR ROL 030 ISR ROR : IBIT CONSTANT DOES> @ >R EXTRA? DN? IF RD SRC 400 ELSE DROP DUP EAS 4000 THEN OR R> OR , ,EXTRA ,MORE ; ( ea Dn ) ( ea n # ) 000 IBIT BTST 100 IBIT BCHG 200 IBIT BCLR 300 IBIT BSET \ branch, loop, and set conditionals gst850923: SETCLASS [compile] ' cfa SWAP 0 DO I OVER EXECUTE LOOP DROP ; : IBRA 400 * 060000 OR CONSTANT ( label ) DOES> @ SWAP ?>MARK DROP 2+ - DUP ABS 200 < IF LOW OR , ELSE SWAP 2, THEN ; 20 SETCLASS IBRA BRA BSR BHI BLS BCC BCS BNE BEQ BVC BVS BPL BMI BGE BLT BGT BLE : IDBR 400 * 050310 OR CONSTANT ( label \ Dn - ) DOES> @ SWAP RS OR , ?>MARK DROP - , ; 20 SETCLASS IDBR DXIT DBRA DBHI DBLS DBCC DBCS DBNE DBEQ DBVC DBVS DBPL DBMI DBGE DBLT DBGT DBLE : ISET 400 * 050300 OR CONSTANT ( ea ) DOES> @ SRC , ,MORE ; 20 SETCLASS ISET SET SNO SHI SLS SCC SCS SNE SEQ SVC SVS SPL SMI SGE SLT SGT SLE \ moves gst850923: MOVE EXTRA? 7700 AND SRC SZ300 , ,MORE ,EXTRA ; ( ea ea ) : MOVEQ RD SWAP LOW OR 070000 OR , ; ( n Dn ) : MOVE>USP RS 047140 OR , ; ( An ) : MOVE<USP RS 047150 OR , ; ( An ) : MOVEM> EXTRA? EAS 044200 OR -SZ1 , , ,EXTRA ; ( n ea ) : MOVEM< EXTRA? EAS 046200 OR -SZ1 , , ,EXTRA ; ( n ea ) : MOVEP DN? IF RD SWAP RS OR 410 OR ELSE RS ROT RD OR 610 OR THEN -SZ1 2, ; ( Dm d An ) ( d An Dm ) \ : LMOVE 7700 AND SWAP EAS OR 20000 OR , ; \ ( long reg move ) \ odds and ends gst850923: CMPM RD SWAP RS OR 130410 OR SZ3 , ; ( An@+ Am@+ ) : EXG DN? IF SWAP DN? IF 140500 ELSE 140610 THEN >R ELSE SWAP DN? IF 140610 ELSE 140510 THEN >R SWAP THEN RS DST R> OR , ; ( Rn Rm ) : EXT RS 044200 OR -SZ1 , ; ( Dn ) : SWAP RS 044100 OR , ; ( Dn ) : STOP 47162 2, ; ( n ) : TRAP 17 AND 47100 OR , ; ( n ) : LINK RS 047120 OR 2, ; ( n An ) : UNLK RS 047130 OR , ; ( An ) : EOR EXTRA? EAS DST SZ3 130400 OR , ,EXTRA ; ( Dn ea ) : CMP 130000 DST SRC SZ3 , ,MORE ; ( ea Dn ) \ arithmetic and logic gst850923: IBCD CONSTANT DOES> @ DST OVER RS OR SWAP ms IF 10 OR THEN , ; ( Dn Dm ) ( An@- Am@- ) 140400 IBCD ABCD 100400 IBCD SBCD : IDD CONSTANT DOES> @ DST OVER RS OR SWAP ms IF 10 OR THEN SZ3 , ; ( Dn Dm ( An@- Am@-) 150400 IDD ADDX 110400 IDD SUBX : IDEA CONSTANT DOES> @ >R DN? ( ea Dn ) ( Dn ea ) IF RD SRC R> OR SZ3 , ,MORE ELSE EXTRA? EAS DST 400 OR R> OR SZ3 , ,EXTRA THEN ; 150000 IDEA ADD 110000 IDEA SUB 140000 IDEA AND 100000 IDEA OR : IEAD CONSTANT DOES> @ DST SRC , ,MORE ; ( ea Dn ) 040600 IEAD CHK 100300 IEAD DIVU 100700 IEAD DIVS 140300 IEAD MULU 140700 IEAD MULS \ arithmetic and control gst850923: IEA CONSTANT DOES> @ SRC , ,MORE ; ( ea ) 047200 IEA JSR 047300 IEA JMP 042300 IEA MOVE>CCR 040300 IEA MOVE<SR 043300 IEA MOVE>SR 044000 IEA NBCD 044100 IEA PEA 045300 IEA TAS : IEAS CONSTANT DOES> @ SRC SZ3 , ,MORE ; ( ea ) 041000 IEAS CLR 043000 IEAS NOT 042000 IEAS NEG 040000 IEAS NEGX 045000 IEAS TST : ICON CONSTANT DOES> @ , ; 47160 ICON RESET 47161 ICON NOP 47163 ICON RTE 47165 ICON RTS \ structured conditionals +/- 256 bytes gst850923 HEX : THEN ?>RESOLVE ; : IF , ?>MARK ; : ELSE 6000 IF 2SWAP THEN ; : BEGIN ?<MARK ; : UNTIL , ?<RESOLVE ; : AGAIN 6000 UNTIL ; : WHILE IF ; : REPEAT 2SWAP AGAIN THEN ; : DO ?>MARK DROP SWAP ; : LOOP DBRA ; DECIMAL \ structured conditionals +/- 256 bytes gst850916 HEX 6400 constant CARRY 6500 constant NOCARRY 6600 CONSTANT 0= 6700 CONSTANT 0<> 6800 constant OVERFLOW 6900 constant NOOVERFLOW 6A00 CONSTANT 0< 6B00 CONSTANT 0>= 6C00 CONSTANT < 6D00 CONSTANT >= 6E00 CONSTANT <= 6F00 CONSTANT > DECIMAL \ end of assembler gst851114 : LMOVE \ ... | macro meaning ... long move word LONG move WORD ; \ be long one move then back : NEXT \ -- | a macro for next word \ init size to word BP ) JMP \ using a single next located at 0(bp) \ IP )+ W MOVE \ ptr to cfa \ 0 W BP di) OS MOVE \ get cfa itself \ 0 OS BP di) JMP \ jmp indirect to code ; \ that's the macro FORTH definitions
